home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tj50dsk1.zip / STRNTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-01-31  |  12KB  |  477 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.00                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  StrnTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {$S-,R-,V-,D-}       
  18.  
  19. unit StrnTTT5;
  20.  
  21. interface
  22.  
  23. CONST
  24.     Floating = 255;
  25.  
  26. Function Squeeze(L:char;Str:string;Width:byte): string;
  27. Function First_Capital_Pos(Str:string): byte;
  28. Function First_Capital(Str:string): char;
  29. Function PadLeft(Str:string;Size:byte;Pad:char):string;
  30. Function PadCenter(Str:string;Size:byte;Pad:char):string;
  31. Function PadRight(Str:string;Size:byte;Pad:char):string;
  32. Function Last(N:byte;Str:string):string;
  33. Function First(N:byte;Str:string):string;
  34. Function Upper(Str:string):string;
  35. Function Lower(Str:string):string;
  36. Function Proper(Str:string):string;
  37. Function OverType(N:byte;StrS,StrT:string):string;
  38. Function Strip(L,C:char;Str:string):string;
  39. Function LastPos(C:Char;Str:string):byte;
  40. Function PosWord(Wordno:byte;Str:string):byte;
  41. Function WordCnt(Str:string):byte;
  42. Function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  43. Function Str_to_Int(Str:string):integer;
  44. Function Str_to_Long(Str:string):Longint;
  45. Function Str_to_Real(Str:string):real;
  46. Function Real_to_str(Number:real;Decimals:byte):string;
  47. Function Int_to_Str(Number:longint):string;
  48. Function Real_to_SciStr(Number:real; D:byte):string;
  49.  
  50. implementation
  51.  
  52.  Function Squeeze(L:Char; Str:string;Width:byte): string;
  53.  {}
  54.  const more:string[1] = #26;
  55.  var temp : string;
  56.  begin
  57.      If Width = 0 then
  58.      begin
  59.          Squeeze := '';
  60.          exit;
  61.      end;
  62.      Fillchar(Temp[1],Width,' ');
  63.      Temp[0] := chr(Width);
  64.      If Length(Str) < Width then
  65.         Move(Str[1],Temp[1],length(Str))
  66.      else
  67.      begin
  68.          If upcase(L) = 'L' then
  69.          begin
  70.              Move(Str[1],Temp[1],pred(width));
  71.              Move(More[1],Temp[Width],1);
  72.          end
  73.          else
  74.          begin
  75.              Move(More[1],Temp[1],1);
  76.              Move(Str[length(Str)-width+2],Temp[2],pred(width));
  77.          end;
  78.      end;
  79.      Squeeze := Temp;
  80.  end; {of func Squeeze}
  81.  
  82.  Function First_Capital_Pos(Str : string): byte;
  83.  {}
  84.  var StrPos : byte;
  85.  begin
  86.      StrPos := 1;
  87.      While (StrPos <= length(Str))  and ((Str[StrPos] in ['A'..'Z']) = false) do
  88.             StrPos := Succ(StrPos);
  89.      If StrPos > length(Str) then
  90.         First_Capital_Pos  := 0
  91.      else
  92.         First_Capital_Pos := StrPos;
  93.  end; {of func First_Capital_Pos}
  94.  
  95.  Function First_capital(Str : string): char;
  96.  {}
  97.  var B : byte;
  98.  begin
  99.      B := First_Capital_Pos(Str);
  100.      If B > 0 then
  101.         First_Capital := Str[B]
  102.      else
  103.         First_Capital := #0;
  104.  end; {of func First_capital}
  105.  
  106. Function PadLeft(Str:string;Size:byte;Pad:char):string;
  107. var temp : string;
  108. begin
  109.     Fillchar(Temp[1],Size,Pad);
  110.     Temp[0] := chr(Size);
  111.     If Length(Str) <= Size then
  112.        Move(Str[1],Temp[1],length(Str))
  113.     else
  114.        Move(Str[1],Temp[1],size);
  115.     PadLeft := Temp;
  116. end;
  117.  
  118. Function PadCenter(Str:string;Size:byte;Pad:char):string;
  119. var temp : string;
  120. L : byte;
  121. begin
  122.     Fillchar(Temp[1],Size,Pad);
  123.     Temp[0] := chr(Size);
  124.     L := length(Str);
  125.     If L <= Size then
  126.        Move(Str[1],Temp[((Size - L) div 2) + 1],L)
  127.     else
  128.        Move(Str[((L - Size) div 2) + 1],Temp[1],Size);
  129.     PadCenter := temp;
  130. end; {center}
  131.  
  132. Function PadRight(Str:string;Size:byte;Pad:char):string;
  133. var
  134.   temp : string;
  135.   L : integer;
  136. begin
  137.     Fillchar(Temp[1],Size,Pad);
  138.     Temp[0] := chr(Size);
  139.     L := length(Str);
  140.     If L <= Size then
  141.        Move(Str[1],Temp[succ(Size - L)],L)
  142.     else
  143.        Move(Str[1],Temp[1],size);
  144.     PadRight := Temp;
  145. end;
  146.  
  147. Function Last(N:byte;Str:string):string;
  148. var Temp : string;
  149. begin
  150.     If N > length(Str) then
  151.        Temp := Str
  152.     else
  153.        Temp := copy(Str,succ(length(Str) - N),N);
  154.     Last := Temp;
  155. end;  {Func Last}
  156.  
  157. Function First(N:byte;Str:string):string;
  158. var Temp : string;
  159. begin
  160.     If N > length(Str) then
  161.        Temp := Str
  162.     else
  163.        Temp := copy(Str,1,N);
  164.     First := Temp;
  165. end;  {Func First}
  166.  
  167. Function Upper(Str:string):string;
  168. var
  169.   I : integer;
  170. begin
  171.     For I := 1 to length(Str) do
  172.         Str[I] := Upcase(Str[I]);
  173.     Upper := Str;
  174. end;  {Func Upper}
  175.  
  176. Function Lower(Str:string):string;
  177. var
  178.   I : integer;
  179. begin
  180.     For I := 1 to length(Str) do
  181.         If ord(Str[I]) in [65..90] then
  182.            Str[I] := chr(ord(Str[I]) + 32);
  183.     Lower := Str;
  184. end;  {Func Lower}
  185.  
  186. Function Proper(Str:string):string;
  187. var
  188.   I : integer;
  189.   SpaceBefore: boolean;
  190. begin
  191.     SpaceBefore := true;
  192.     Str := lower(Str);
  193.     For I := 1 to length(Str) do
  194.         If SpaceBefore and (ord(Str[I]) in [97..122]) then
  195.         begin
  196.             SpaceBefore := False;
  197.             Str[I] := Upcase(Str[I]);
  198.         end
  199.         else
  200.             If (SpaceBefore = False) and (Str[I] = ' ') then
  201.                 SpaceBefore := true;
  202.     Proper := Str;
  203. end;
  204.  
  205. Function OverType(N:byte;StrS,StrT:string):string;
  206. {Overlays StrS onto StrT at Pos N}
  207. var
  208.   L : byte;
  209.   StrN : string;
  210. begin
  211.     L := N + pred(length(StrS));
  212.     If L < length(StrT) then
  213.        L := length(StrT);
  214.     If L > 255 then
  215.        Overtype := copy(StrT,1,pred(N)) + copy(StrS,1,255-N)
  216.         else
  217.     begin
  218.        Fillchar(StrN[1],L,' ');
  219.        StrN[0] := chr(L);
  220.        Move(StrT[1],StrN[1],length(StrT));
  221.        Move(StrS[1],StrN[N],length(StrS));
  222.        OverType := StrN;
  223.     end;
  224. end;  {Func OverType}
  225.  
  226. Function Strip(L,C:char;Str:string):string;
  227. {L is left,center,right,all,ends}
  228. var I :  byte;
  229. begin
  230.     Case Upcase(L) of
  231.     'L' : begin       {Left}
  232.               While (Str[1] = C) and (length(Str) > 0) do
  233.                     Delete(Str,1,1);
  234.           end;
  235.     'R' : begin       {Right}
  236.               While (Str[length(Str)] = C) and (length(Str) > 0) do
  237.                     Delete(Str,length(Str),1);
  238.           end;
  239.     'B' : begin       {Both left and right}
  240.               While (Str[1] = C) and (length(Str) > 0) do
  241.                     Delete(Str,1,1);
  242.               While (Str[length(Str)] = C) and (length(Str) > 0)  do
  243.                     Delete(Str,length(Str),1);
  244.           end;
  245.     'A' : begin       {All}
  246.               I := 1;
  247.               Repeat
  248.                    If (Str[I] = C) and (length(Str) > 0) then
  249.                       Delete(Str,I,1)
  250.                    else
  251.                       I := succ(I);
  252.               Until (I > length(Str)) or (Str = '');
  253.           end;
  254.     end;
  255.     Strip := Str;
  256. end;  {Func Strip}
  257.  
  258. Function LastPos(C:Char;Str:string):byte;
  259. Var I : byte;
  260. begin
  261.     I := succ(Length(Str));
  262.     Repeat
  263.          I := Pred(I);
  264.     Until (I = 0) or (Str[I] = C);
  265.     LastPos := I;
  266. end;  {Func LastPos}
  267.  
  268. Function LocWord(StartAT,Wordno:byte;Str:string):byte;
  269. {local proc used by PosWord and Extract word}
  270. var
  271.   W,L: integer;
  272.   Spacebefore: boolean;
  273. begin
  274.     If (Str = '') or (wordno < 1) or (StartAT > length(Str)) then
  275.     begin
  276.         LocWord := 0;
  277.         exit;
  278.     end;
  279.     SpaceBefore := true;
  280.     W := 0;
  281.     L := length(Str);
  282.     StartAT := pred(StartAT);
  283.     While (W < Wordno) and (StartAT <= length(Str)) do
  284.     begin
  285.         StartAT := succ(StartAT);
  286.         If SpaceBefore and (Str[StartAT] <> ' ') then
  287.         begin
  288.             W := succ(W);
  289.             SpaceBefore := false;
  290.         end
  291.         else
  292.             If (SpaceBefore = false) and (Str[StartAT] = ' ') then
  293.                 SpaceBefore := true;
  294.     end;
  295.     If W = Wordno then
  296.        LocWord := StartAT
  297.     else
  298.        LocWord := 0;
  299. end;
  300.  
  301. Function PosWord(Wordno:byte;Str:string):byte;
  302. begin
  303.     PosWord := LocWord(1,wordno,Str);
  304. end;  {Func Word}
  305.  
  306. Function WordCnt(Str:string):byte;
  307. var
  308.   W,I: integer;
  309.   SpaceBefore: boolean;
  310. begin
  311.     If Str = '' then
  312.     begin
  313.         WordCnt := 0;
  314.         exit;
  315.     end;
  316.     SpaceBefore := true;
  317.     W := 0;
  318.     For  I :=  1 to length(Str) do
  319.     begin
  320.         If SpaceBefore and (Str[I] <> ' ') then
  321.         begin
  322.             W := succ(W);
  323.             SpaceBefore := false;
  324.         end
  325.         else
  326.             If (SpaceBefore = false) and (Str[I] = ' ') then
  327.                 SpaceBefore := true;
  328.     end;
  329.     WordCnt := W;
  330. end;
  331.  
  332. Function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  333. var Start, finish : integer;
  334. begin
  335.     If Str = '' then
  336.     begin
  337.         ExtractWords := '';
  338.         exit;
  339.     end;
  340.     Start := LocWord(1,StartWord,Str);
  341.     If Start <> 0 then
  342.        finish := LocWord(Start,succ(NoWords),Str)
  343.     else
  344.     begin
  345.         ExtractWords := '';
  346.         exit;
  347.     end;
  348.     If finish <> 0 then
  349.        Repeat
  350.            finish := pred(finish);
  351.        Until Str[finish] <> ' '
  352.     else
  353.        finish := length(Str);
  354.     ExtractWords := copy(Str,Start,succ(finish-Start));
  355. end;  {Func ExtractWords}
  356.  
  357. Function Int_to_Str(Number:longint):string;
  358. var Temp : string;
  359. begin
  360.     Str(Number,temp);
  361.     Int_to_Str := temp;
  362. end;
  363.  
  364. Function Str_to_Real(Str:string):real;
  365. var
  366.   code : integer;
  367.   Temp : real;
  368. begin
  369.     If length(Str) = 0 then
  370.        Str_to_Real := 0
  371.     else
  372.     begin
  373.         If Copy(Str,1,1)='.' Then
  374.            Str:='0'+Str;
  375.         If (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  376.            Insert('0',Str,2);
  377.         If Str[length(Str)] = '.' then
  378.            Delete(Str,length(Str),1);
  379.        val(Str,temp,code);
  380.        if code = 0 then
  381.           Str_to_Real := temp
  382.        else
  383.           Str_to_Real := 0;
  384.     end;
  385. end;
  386.  
  387. function Real_to_str(Number:real;Decimals:byte):string;
  388. var Temp : string;
  389. begin
  390.     Str(Number:20:Decimals,Temp);
  391.     repeat
  392.          If copy(Temp,1,1) = ' ' then delete(Temp,1,1);
  393.     until copy(temp,1,1) <> ' ';
  394.     If Decimals = Floating then
  395.     begin
  396.        Temp := Strip('R','0',Temp);
  397.        If Temp[Length(temp)] = '.' then
  398.           Delete(temp,Length(temp),1);
  399.     end;
  400.     Real_to_Str := Temp;
  401. end;
  402.  
  403. Function  Str_to_Int(Str:string):integer;
  404. var temp,code : integer;
  405. begin
  406.     If length(Str) = 0 then
  407.        Str_to_Int := 0
  408.     else
  409.     begin
  410.        val(Str,temp,code);
  411.        if code = 0 then
  412.           Str_to_Int := temp
  413.        else
  414.           Str_to_Int := 0;
  415.     end;
  416. end;
  417.  
  418. Function Str_to_Long(Str:string):Longint;
  419. var
  420.   code : integer;
  421.   Temp : longint;
  422. begin
  423.     If length(Str) = 0 then
  424.        Str_to_Long := 0
  425.     else
  426.     begin
  427.        val(Str,temp,code);
  428.        if code = 0 then
  429.           Str_to_Long := temp
  430.        else
  431.           Str_to_Long := 0;
  432.     end;
  433. end;
  434.  
  435. Function Real_to_SciStr(Number:real; D:byte):string;
  436. {Credits: Michael Harris, Houston. Thanks!}
  437. Const
  438.     DamnNearUnity = 9.99999999E-01;
  439. Var
  440.     Temp : real;
  441.     Power: integer;
  442.     Value: string;
  443.     Sign : char;
  444. begin
  445.     If Number = 1.0 then
  446.        Real_to_SciStr := '1.000'
  447.     else
  448.     begin
  449.         Temp := Number;
  450.         Power := 0;
  451.         If Number > 1.0 then
  452.         begin
  453.            While Temp >= 10.0 do
  454.            begin
  455.                Inc(Power);
  456.                Temp := Temp/10.0;
  457.            end;
  458.            Sign := '+';
  459.         end
  460.         else
  461.         begin
  462.             While Temp < DamnNearUnity do
  463.             begin
  464.                 Inc(Power);
  465.                 Temp := Temp * 10.0;
  466.             end;
  467.             Sign := '-';
  468.         end;
  469.         Value := Real_To_Str(Temp,D);
  470.         Real_to_SciStr := Value+' E'+Sign+Padright(Int_to_Str(Power),2,'0');
  471.     end;
  472. end; {func Real_to_SciStr}
  473.  
  474.  
  475. end.
  476.  
  477.